home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Atari Mega Archive 1
/
Atari Mega Archive - Volume 1.iso
/
language
/
examples.zoo
/
closette
/
closette.tst
< prev
next >
Wrap
Lisp/Scheme
|
1991-10-22
|
64KB
|
1,949 lines
;;;-*-Mode:LISP; Package: CLOSETTE; Base:10; Syntax:Common-lisp -*-
(in-package 'closette :use '(lisp))
;;; CLOSette tests
;;; From chapter 1
(defclass rectangle ()
((height :initform 0.0 :initarg :height)
(width :initform 0.0 :initarg :width)))
(defclass color-mixin ()
((cyan :initform 0 :initarg :cyan)
(magenta :initform 0 :initarg :magenta)
(yellow :initform 0 :initarg :yellow)))
(defclass color-rectangle (color-mixin rectangle)
((clearp :initform (y-or-n-p "But is it transparent?")
:initarg :clearp :accessor clearp)))
(defgeneric paint (x))
(defmethod paint ((x rectangle)) ;Method #1
(vertical-stroke (slot-value x 'height)
(slot-value x 'width)))
(defmethod paint :before ((x color-mixin)) ;Method #2
(set-brush-color (slot-value x 'cyan)
(slot-value x 'magenta)
(slot-value x 'yellow)))
(defmethod paint ((x color-rectangle)) ;Method #3
(unless (clearp x) (call-next-method)))
(setq door
(make-instance 'color-rectangle
:width 38 :height 84 :cyan 60 :yellow 55 :clearp nil))
(defun vertical-stroke (x y) (declare (ignore x y)) (values))
(defun set-brush-color (x y z) (declare (ignore x y z)) (values))
(paint door)
;;; test method combination
(defgeneric mctest (x))
(defmethod mctest :around ((x integer))
(format t "(:around integer)")
(call-next-method))
(defmethod mctest :around ((x number))
(format t "(:around number)")
(call-next-method))
(defmethod mctest :before ((x number))
(format t "(:before number)"))
(defmethod mctest ((x number))
(format t "(primary number)")
(1+ (call-next-method)))
(defmethod mctest :after ((x number))
(format t "(:after number)"))
(defmethod mctest :before ((x t))
(format t "(:before t)"))
(defmethod mctest ((x t))
(format t "(primary t)")
100)
(defmethod mctest :after ((x t))
(format t "(:after t)"))
(mctest 1)
#|(:around integer)(:around number)(:before number)(:before t)
(primary number)(primary t)(:after t)(:after number)
101|#
;;; following chapter 1
(pprint (macroexpand
'(defclass color-rectangle (color-mixin rectangle)
((clearp :initform (y-or-n-p "But is it transparent?")
:initarg :clearp :accessor clearp)))))
#|(ensure-class 'color-rectangle
:direct-superclasses
(list (find-class 'color-mixin) (find-class 'rectangle))
:direct-slots
(list
(list :name 'clearp :initform
'(y-or-n-p "But is it transparent?")
:initfunction
(function
(lambda nil (y-or-n-p "But is it transparent?")))
:initargs
'(:clearp)
:readers
'(clearp)
:writers
'((setf clearp)))))
|#
;;; original compute-slots
(defun original-compute-slots (class)
(mapcar #'(lambda (slot)
(make-effective-slot-definition
:name (slot-definition-name slot)
:initform (slot-definition-initform slot)
:initfunction (slot-definition-initfunction slot)
:initargs (slot-definition-initargs slot)))
(remove-duplicates
(mapappend #'class-direct-slots
(class-precedence-list class))
:key #'slot-definition-name
:from-end t)))
(equal (original-compute-slots (find-class 'color-rectangle))
(compute-slots (find-class 'color-rectangle)))
#|T|#
(pprint (macroexpand
'(defgeneric paint (x))))
#|(ensure-generic-function 'paint :lambda-list '(x))|#
(pprint (macroexpand
'(defmethod paint :before ((x color-mixin)) ; Method#2
(set-brush-color (slot-value x 'cyan)
(slot-value x 'magenta)
(slot-value x 'yellow)))))
#|(ensure-method (find-generic-function 'paint)
:lambda-list
'(x)
:qualifiers
'(:before)
:specializers
(list (find-class 'color-mixin))
:body
'(block paint
(set-brush-color (slot-value x 'cyan)
(slot-value x 'magenta)
(slot-value x 'yellow)))
:environment
(top-level-environment))
|#
(find-generic-function 'clearp)
#|#<Closette:Standard-Generic-Function CLOSETTE::CLEARP 16060700>|#
(clearp (make-instance 'color-rectangle :clearp t))
#|T|#
;;; change-class
(setq o1 (make-instance 'rectangle :height 10 :width 20))
(describe-object o1 *standard-output*)
#| A CLOS object
Printed representation: #<Rectangle 16166710>
Class: #<Standard-Class rectangle 15253764>
Structure
height <- 10
width <- 20
|#
(change-class o1 'color-mixin)
(describe-object o1 *standard-output*)
#| A CLOS object
Printed representation: #<Color-Mixin 16166710>
Class: #<Standard-Class color-mixin 15274440>
Structure
cyan <- 0
magenta <- 0
yellow <- 0
|#
(change-class o1 'standard-object)
(describe-object o1 *standard-output*)
#| A CLOS object
Printed representation: #<Standard-Object 16166710>
Class: #<Standard-Class standard-object 15071700>
Structure
|#
(sub-specializer-p (find-class 'color-mixin)
(find-class 'rectangle)
(find-class 'color-rectangle))
#|T|#
(sub-specializer-p (find-class 'rectangle)
(find-class 'rectangle)
(find-class 'color-rectangle))
#|NIL|#
;;; exercise
(defvar all-tables (make-hash-table :test #'eq))
(defun classes-to-applicable-methods-table (gf)
(let ((table (gethash gf all-tables nil)))
(unless table
(setq table (make-hash-table :test #'equal))
(setf (gethash gf all-tables) table))
table))
(defun better-apply-generic-function (gf args)
(let* ((required-classes
(mapcar #'class-of (required-portion gf args)))
(applicable-methods
(or (gethash required-classes
(classes-to-applicable-methods-table gf)
nil)
(setf (gethash required-classes
(classes-to-applicable-methods-table gf))
(compute-applicable-methods-using-classes
gf required-classes)))))
(if (null applicable-methods)
(error "No matching method for the~@
generic function ~S,~@
when called with arguments ~:S." gf args)
(apply-methods gf args applicable-methods))))
(better-apply-generic-function
(find-generic-function 'make-instance)
(list 'rectangle))
;;; From chapter 2:
(defun subclasses* (class)
(remove-duplicates
(cons class
(mapappend #'subclasses*
(class-direct-subclasses class)))))
(defun subclasses (class) (remove class (subclasses* class)))
(subclasses (find-class 'rectangle))
#|(#<Standard-Class COLOR-RECTANGLE>)|#
(defvar my-classes
(mapcar #'class-name
(subclasses (find-class 'standard-object))))
my-classes
#|(color-mixin rectangle
color-rectangle
standard-method
standard-generic-function
standard-class)
|#
(defun display-defclass (class-name)
(pprint (generate-defclass (find-class class-name)))
(values))
(defun generate-defclass (class)
`(defclass ,(class-name class)
,(mapcar #'class-name (class-direct-superclasses class))
,(mapcar #'generate-slot-specification (class-direct-slots class))))
(defun generate-slot-specification (slot)
`(,(slot-definition-name slot)
,@(when (slot-definition-initfunction slot)
`(:initform ,(slot-definition-initform slot)))
,@(when (slot-definition-initargs slot)
(mapappend #'(lambda